perm filename CONMSS.F4[MSS,LCS] blob sn#189913 filedate 1975-11-30 generic text, type T, neo UTF8
00010	C  CONVERTS .DAT TO .DMD      LOAD WITH MSSIO.FAI[XX,LCS]
00100		IMPLICIT INTEGER(A-Q,S-Z)
00200		REAL DIS,PWDS,DISX,A,B,STFF,CENTR,POS ,UD
00400		COMMON/STF/RSTFAC(-3/4),RSTJ2/POSI/STFF(-3/4),X,Y
00500		COMMON/SCM/V(78),ISCR,LCNT,IR,LIST(200)
00550	C  ORDER OF COMMON BLOCKS MUST STAY AS IS!
00600		COMMON/XRN/RN(2050)
00700	 	1 /PTR/PWDS(250),ITEM,L,I,IX
00770		DIMENSION KWDS(250)
00785		EQUIVALENCE (KWDS,PWDS)
00800	83	TYPE 1
00900	1	FORMAT(' TYPE NAME 1, (N)  ',$)
01000	2	FORMAT(' TYPE FINAL NAME  ',$)
01100	3	FORMAT(A5,I)
01200	4	FORMAT(1XA5)
01300		ACCEPT 3,NAME,T
01350		NAMZ=NAME
01375	10	IF(T.NE.0)GO TO 13
01400		IF(LOOKD(NAME))GO TO 284
01500		NAME=NAMZ+256
01600		IF(LOOKD(NAME).GE.0)GO TO 83
01700		NAMZ=NAME
01800	C  FOUND NO MORE TO READ
01900	284	CALL IFILE(21,NAME)
02000	2202	READ(21),X,Y,
02100		1 (PWDS(K),K=1,X+1),(RN(K),K=1,Y-1),ISCR,(V(K),K=1,ISCR),
02200		1 LCNT,(LIST(K),K=1,LCNT),RSTFAC,STFF,RPOS
02300		X=X+2
02305	C WRITE EXTRA WORD 
02310		DO 77 K=1,X
02320	77	KWDS(K)=PWDS(K)
02400	CC	Y=Y-1
02600		IR=0
02650	C FLAG FOR NO DPY BUFFER
02700	19	CALL PUTFIL(NAME)
02800		CALL FASTOU(RSTFAC,128)
02900		CALL FASTOU(PWDS,X)
03000		CALL FASTOU(RN,Y)
03100		IF(LCNT.GT.1)CALL FASTOU(LIST,LCNT)
03300		CALL FINFIL
03350		TYPE 4,NAME
03400	20	NAME=NAME+2
03500		GO TO 10
03600	13	IF(LOOKF(NAME))GO TO 14
03700		NAME=NAMZ+256
03800		IF(LOOKF(NAME).GE.0)GO TO 83
03900		NAMZ=NAME
04000	C  FOUND NO MORE TO READ
04100	14	CALL GETFIL(NAME)
05000		CALL FASTIN(RSTFAC,128)
05100		CALL FASTIN(PWDS,X)
05200		CALL FASTIN(RN,Y)
05400		IF(LCNT.GT.1)CALL FASTIN(LIST,LCNT)
05450		Q=0
05500		DO 15 K=1,X-1
05600		J=KWDS(K)
05700		IF(RN(J+1).NE.16)GO TO 15
05800	C TO CONVERT TEXT TO NEW FORMAT
05850		A=0
05900		DO 16 N=J+6,J+8
06000		R=RN(N)
06100		M=R
06150		IF(M.GE.1000000)GO TO 20
06175	C  JUMP OUT IF ALREADY CONVERTED
06200	16	IF(M.NE.R)A=-1
06300		IF(A.EQ.0)GO TO 15
06400	17	DO 18 N=J+6,J+8
06500	18	RN(N)=RN(N)*100.0
06550		Q=-1
06600	15	CONTINUE
06700		IF(Q)GO TO 19
06750		GO TO 20
06800		END